home *** CD-ROM | disk | FTP | other *** search
/ Pascal Super Library / Pascal Super Library (CW International)(1997).bin / LIBRARY / PASCALL / PLASMA / PLASMA.PAS < prev    next >
Pascal/Delphi Source File  |  1992-11-03  |  4KB  |  145 lines
  1. { Turbo Pascal 4.0 source code }
  2. {$I-}
  3. program plasma;
  4. uses
  5.      Crt,Dos;
  6. const
  7.      F = 2.0; { the "roughness" of the image }
  8. type
  9.      ColorValue = record
  10.           Rvalue,Gvalue,Bvalue: byte;
  11.      end;
  12.      PaletteType = array [0..255] of ColorValue;
  13. var
  14.      ch: char;
  15.      i: integer;
  16.      p: PaletteType;
  17.      image: file;
  18.      ok: boolean;
  19.  
  20. procedure SetVGApalette(var tp: PaletteType);
  21. var
  22.      regs: Registers;
  23. begin { procedure SetVGApalette }
  24.      with regs do
  25.      begin
  26.           AX:=$1012;
  27.           BX:=0; { first register to set }
  28.           CX:=256; { number of registers to set }
  29.           ES:=Seg(tp); DX:=Ofs(tp);
  30.      end;
  31.      Intr($10,regs);
  32. end; { procedure SetVGApalette }
  33.  
  34. procedure PutPixel(x,y: integer; c: byte);
  35. begin { procedure PutPixel }
  36.      mem[$A000:word(320*y+x)]:=c;
  37. end; { procedure PutPixel }
  38.  
  39. function GetPixel(x,y: integer): byte;
  40. begin { function GetPixel }
  41.      GetPixel:=mem[$A000:word(320*y+x)];
  42. end; { function GetPixel }
  43.  
  44. procedure adjust(xa,ya,x,y,xb,yb: integer);
  45. var
  46.      d: integer;
  47.      v: real;
  48. begin { procedure adjust }
  49.      if GetPixel(x,y)<>0 then exit;
  50.      d:=Abs(xa-xb)+Abs(ya-yb);
  51.      v:=(GetPixel(xa,ya)+GetPixel(xb,yb))/2+(random-0.5)*d*F;
  52.      if v<1 then v:=1;
  53.      if v>=193 then v:=192;
  54.      PutPixel(x,y,Trunc(v));
  55. end; { procedure adjust }
  56.  
  57. procedure subDivide(x1,y1,x2,y2: integer);
  58. var
  59.      x,y: integer;
  60.      v: real;
  61. begin { procedure subDivide }
  62.      if KeyPressed then exit;
  63.      if (x2-x1<2) and (y2-y1<2) then exit;
  64.  
  65.      x:=(x1+x2) div 2;
  66.      y:=(y1+y2) div 2;
  67.  
  68.      adjust(x1,y1,x,y1,x2,y1);
  69.      adjust(x2,y1,x2,y,x2,y2);
  70.      adjust(x1,y2,x,y2,x2,y2);
  71.      adjust(x1,y1,x1,y,x1,y2);
  72.  
  73.      if GetPixel(x,y)=0 then
  74.      begin
  75.           v:=(GetPixel(x1,y1)+GetPixel(x2,y1)+GetPixel(x2,y2)+GetPixel(x1,y2))/4;
  76.           PutPixel(x,y,Trunc(v));
  77.      end;
  78.  
  79.      subDivide(x1,y1,x,y);
  80.      subDivide(x,y1,x2,y);
  81.      subDivide(x,y,x2,y2);
  82.      subDivide(x1,y,x,y2);
  83. end; { procedure subDivide }
  84.  
  85. procedure rotatePalette(var p: PaletteType; n1,n2,d: integer);
  86. var
  87.      q: PaletteType;
  88. begin { procedure rotatePalette }
  89.      q:=p;
  90.      for i:=n1 to n2 do
  91.           p[i]:=q[n1+(i+d) mod (n2-n1+1)];
  92.      SetVGApalette(p);
  93. end; { procedure rotatePalette }
  94.  
  95. begin
  96.      Inline($B8/$13/0/$CD/$10); { select video mode 13h (320x200 with 256 colors) }
  97.  
  98.      with p[0] do               { set background palette entry to grey }
  99.      begin
  100.           Rvalue:=32;
  101.           Gvalue:=32;
  102.           Bvalue:=32;
  103.      end;
  104.  
  105.      for i:=0 to 63 do { create the color wheel }
  106.      begin
  107.           with p[i+1] do begin Rvalue:=i; Gvalue:=63-i; Bvalue:=0; end;
  108.           with p[i+65] do begin Rvalue:=63-i; Gvalue:=0; Bvalue:=i; end;
  109.           with p[i+129] do begin Rvalue:=0; Gvalue:=i; Bvalue:=63-i; end;
  110.      end;
  111.  
  112.      SetVGApalette(p);
  113.  
  114.      Assign(image,'PLASMA.IMG');
  115.      Reset(image,1);
  116.      ok:=(ioResult=0);
  117.  
  118.      if not ok or (ParamCount<>0) then { create a new image }
  119.      begin
  120.           Randomize;
  121.  
  122.           PutPixel(0,0,1+Random(192));
  123.           PutPixel(319,0,1+Random(192));
  124.           PutPixel(319,199,1+Random(192));
  125.           PutPixel(0,199,1+Random(192));
  126.  
  127.           subDivide(0,0,319,199);
  128.  
  129.           Rewrite(image,1);
  130.           BlockWrite(image,mem[$A000:0],$FA00);
  131.      end
  132.      else { use the previous image }
  133.           BlockRead(image,mem[$A000:0],$FA00);
  134.  
  135.      Close(image);
  136.  
  137.      repeat
  138.           rotatePalette(p,1,192,+1);
  139.      until KeyPressed;
  140.  
  141.      ch:=ReadKey; if ch=#0 then ch:=ReadKey;
  142.  
  143.      TextMode(LastMode);
  144. end.
  145.